home *** CD-ROM | disk | FTP | other *** search
/ ADA Programming Guide / ADA Programming Guide.iso / ada_gnu / adainc / s-taprob.adb < prev    next >
Text File  |  1996-01-30  |  23KB  |  709 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                 GNU ADA RUNTIME LIBRARY (GNARL) COMPONENTS               --
  4. --                                                                          --
  5. --      S Y S T E M . T A S K I N G . P R O T E C T E D _ O B J E C T S     --
  6. --                                                                          --
  7. --                                  B o d y                                 --
  8. --                                                                          --
  9. --                             $Revision: 1.19 $                             --
  10. --                                                                          --
  11. --       Copyright (c) 1991,1992,1993,1994, FSU, All Rights Reserved        --
  12. --                                                                          --
  13. -- GNARL is free software; you can redistribute it  and/or modify it  under --
  14. -- terms  of  the  GNU  Library General Public License  as published by the --
  15. -- Free Software  Foundation;  either version 2, or (at  your  option)  any --
  16. -- later  version.  GNARL is distributed  in the hope that  it will be use- --
  17. -- ful, but but WITHOUT ANY WARRANTY;  without even the implied warranty of --
  18. -- MERCHANTABILITY  or  FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Gen- --
  19. -- eral Library Public License  for more details.  You should have received --
  20. -- a  copy of the GNU Library General Public License along with GNARL;  see --
  21. -- file COPYING.LIB.  If not,  write to the  Free Software Foundation,  675 --
  22. -- Mass Ave, Cambridge, MA 02139, USA.                                      --
  23. --                                                                          --
  24. ------------------------------------------------------------------------------
  25.  
  26. with System.Compiler_Exceptions;
  27. --  Used for, "="
  28. --            Raise_Exceptions
  29. --            Exception_ID
  30. --            Compiler_Exceptions.Null_Exception
  31. --            Program_Error_ID
  32.  
  33. with System.Error_Reporting;
  34. --  Used for, System.Error_Reporting.Assert
  35.  
  36. with System.Tasking.Abortion;
  37. --  Used for, Abortion.Defer_Abortion,
  38. --            Abortion.Undefer_Abortion,
  39. --            Abortion.Change_Base_Priority
  40.  
  41. with System.Task_Primitives; use System.Task_Primitives;
  42.  
  43. with System.Tasking.Queuing; use System.Tasking.Queuing;
  44. --  Used for, Queuing.Enqueue,
  45. --            Queuing.Dequeue,
  46. --            Queuing.Head,
  47. --            Queuing.Dequeue_Head,
  48. --            Queuing.Count_Waiting,
  49. --            Queuing.Select_Protected_Entry_Call
  50.  
  51. with System.Tasking.Utilities;
  52. --  Used for, Utilities.ATCB_Ptr,
  53. --            Utilities.ATCB_To_ID,
  54. --            Utilities.ID_To_ATCB,
  55. --            Utilities.Abort_To_Level
  56.  
  57. with System.Tasking.Stages;
  58. pragma Elaborate_All (System.Tasking.Stages);
  59. --  Just for elaboration.
  60.  
  61. with Unchecked_Conversion;
  62.  
  63. package body System.Tasking.Protected_Objects is
  64.  
  65.    procedure Assert (B : Boolean; M : String)
  66.      renames Error_Reporting.Assert;
  67.  
  68.    function ID_To_ATCB (ID : Task_ID) return Utilities.ATCB_Ptr
  69.      renames Tasking.Utilities.ID_To_ATCB;
  70.  
  71.    function ATCB_To_ID (Ptr : Utilities.ATCB_Ptr) return Task_ID
  72.      renames Utilities.ATCB_To_ID;
  73.  
  74.    procedure Defer_Abortion
  75.      renames Abortion.Defer_Abortion;
  76.  
  77.    procedure Internal_Lock
  78.      (Object : Protection_Access;
  79.       Ceiling_Violation : out Boolean);
  80.    --  This version of lock is used internally to lock a protected
  81.    --  object.  It returns a Ceiling_Violation flag instead of raising
  82.    --  program error, avoiding the need for exception handlers in the
  83.    --  runtime to clean up after a ceiling violation.
  84.  
  85.    procedure Internal_Lock_Read_Only
  86.      (Object : Protection_Access;
  87.       Ceiling_Violation : out Boolean);
  88.    --  This version of lock is used internally to lock a protected
  89.    --  object for read access.
  90.    --  It returns a Ceiling_Violation flag instead of raising
  91.    --  program error, avoiding the need for exception handlers in the
  92.    --  runtime to clean up after a ceiling violation.
  93.  
  94.    procedure Undefer_Abortion
  95.      renames Abortion.Undefer_Abortion;
  96.  
  97.    function "=" (L, R : Utilities.ATCB_Ptr) return Boolean
  98.      renames Utilities."=";
  99.  
  100.    function "=" (L, R : Compiler_Exceptions.Exception_ID) return Boolean
  101.      renames Compiler_Exceptions."=";
  102.  
  103.    function Address_To_Protection_Access is new
  104.      Unchecked_Conversion (System.Address, Protection_Access);
  105.  
  106.    function Protection_Access_To_Address is new
  107.      Unchecked_Conversion (Protection_Access, System.Address);
  108.  
  109.    procedure Vulnerable_Cancel_Protected_Entry_Call
  110.      (Caller         : Utilities.ATCB_Ptr;
  111.       Call           : Entry_Call_Link;
  112.       PO             : Protection_Access;
  113.       Call_Cancelled : out Boolean);
  114.    --  This procedure is used to cancel a protected entry call from
  115.    --  within the runtime (including from the interface procedure
  116.    --  Cancel_Protected_Entry_Call).  It assumes that abortion is
  117.    --  deferred.
  118.  
  119.    -----------------------------
  120.    -- Raise_Pending_Exception --
  121.    -----------------------------
  122.  
  123.    procedure Raise_Pending_Exception (Block : Communication_Block) is
  124.       T  : Utilities.ATCB_Ptr := ID_To_ATCB (Block.Self);
  125.       Ex : Compiler_Exceptions.Exception_ID := T.Exception_To_Raise;
  126.    begin
  127.  
  128.       T.Exception_To_Raise := Compiler_Exceptions.Null_Exception;
  129.       Compiler_Exceptions.Raise_Exception (Ex);
  130.    end Raise_Pending_Exception;
  131.  
  132.    ---------------------------
  133.    -- Initialize_Protection --
  134.    ---------------------------
  135.  
  136.    procedure Initialize_Protection
  137.      (Object           : Protection_Access;
  138.       Ceiling_Priority : Integer)
  139.    is
  140.       Init_Priority : Integer := Ceiling_Priority;
  141.  
  142.    begin
  143.       if Init_Priority = Unspecified_Priority then
  144.          Init_Priority := System.Default_Priority;
  145.       end if;
  146.  
  147.       Initialize_Lock (Init_Priority, Object.L);
  148.       Object.Ceiling := System.Priority (Init_Priority);
  149.       Object.Pending_Action := False;
  150.       Object.Pending_Call := null;
  151.       Object.Call_In_Progress := null;
  152.  
  153.       for E in Object.Entry_Queues'Range loop
  154.          Object.Entry_Queues (E).Head := null;
  155.          Object.Entry_Queues (E).Tail := null;
  156.       end loop;
  157.    end Initialize_Protection;
  158.  
  159.    -------------------------
  160.    -- Finalize_Protection --
  161.    -------------------------
  162.  
  163.    procedure Finalize_Protection (Object : Protection_Access) is
  164.    begin
  165.       --  Need to purge entry queues and pending entry call here. ???
  166.  
  167.       Finalize_Lock (Object.L);
  168.    end Finalize_Protection;
  169.  
  170.    -------------------
  171.    -- Internal_Lock --
  172.    -------------------
  173.  
  174.    procedure Internal_Lock
  175.      (Object : Protection_Access;
  176.       Ceiling_Violation : out Boolean) is
  177.    begin
  178.       Write_Lock (Object.L, Ceiling_Violation);
  179.    end Internal_Lock;
  180.  
  181.    -----------------------------
  182.    -- Internal_Lock_Read_Only --
  183.    -----------------------------
  184.  
  185.    procedure Internal_Lock_Read_Only
  186.      (Object : Protection_Access;
  187.       Ceiling_Violation : out Boolean) is
  188.    begin
  189.       Read_Lock (Object.L, Ceiling_Violation);
  190.    end Internal_Lock_Read_Only;
  191.  
  192.    ----------
  193.    -- Lock --
  194.    ----------
  195.  
  196.    procedure Lock (Object : Protection_Access) is
  197.       Ceiling_Violation : Boolean;
  198.    begin
  199.       Internal_Lock (Object, Ceiling_Violation);
  200.       if Ceiling_Violation then
  201.          raise Program_Error;
  202.       end if;
  203.    end Lock;
  204.  
  205.    --------------------
  206.    -- Lock_Read_Only --
  207.    --------------------
  208.  
  209.    procedure Lock_Read_Only (Object : Protection_Access) is
  210.       Ceiling_Violation : Boolean;
  211.    begin
  212.       Internal_Lock_Read_Only (Object, Ceiling_Violation);
  213.       if Ceiling_Violation then
  214.          raise Program_Error;
  215.       end if;
  216.    end Lock_Read_Only;
  217.  
  218.    ------------
  219.    -- Unlock --
  220.    ------------
  221.  
  222.    procedure Unlock (Object : Protection_Access) is
  223.       Caller : Utilities.ATCB_Ptr := ID_To_ATCB (Self);
  224.       Error  : Boolean;
  225.    begin
  226.       if Object.Pending_Action then
  227.          Object.Pending_Action := False;
  228.          Write_Lock (Caller.L, Error);
  229.          Caller.New_Base_Priority := Object.Old_Base_Priority;
  230.          Abortion.Change_Base_Priority (Caller);
  231.          Unlock (Caller.L);
  232.       end if;
  233.       Unlock (Object.L);
  234.    end Unlock;
  235.  
  236.    --------------------------
  237.    -- Protected_Entry_Call --
  238.    --------------------------
  239.  
  240.    procedure Protected_Entry_Call
  241.      (Object    : Protection_Access;
  242.       E         : Protected_Entry_Index;
  243.       Uninterpreted_Data : System.Address;
  244.       Mode      : Call_Modes;
  245.       Block     : out Communication_Block)
  246.    is
  247.       Level : ATC_Level;
  248.       Caller : Utilities.ATCB_Ptr := ID_To_ATCB (Self);
  249.  
  250.    begin
  251.       Block.Self := ATCB_To_ID (Caller);
  252.       Caller.ATC_Nesting_Level := Caller.ATC_Nesting_Level + 1;
  253.       Level := Caller.ATC_Nesting_Level;
  254.  
  255.       Object.Pending_Call := Caller.Entry_Calls (Level)'Access;
  256.  
  257.       --  The caller's lock is not needed here.  The call record does not
  258.       --  need protection, since other tasks only access these records
  259.       --  when they are queued, which this one is not.  The Pending_Call
  260.       --  field is protected, and will be until the call is removed by
  261.       --  Next_Entry_Call.
  262.  
  263.       Object.Pending_Call.Next := null;
  264.       Object.Pending_Call.Call_Claimed := False;
  265.       Object.Pending_Call.Mode := Mode;
  266.       Object.Pending_Call.Abortable := True;
  267.       Object.Pending_Call.Done := False;
  268.       Object.Pending_Call.E := Entry_Index (E);
  269.       Object.Pending_Call.Prio := Caller.Current_Priority;
  270.       Object.Pending_Call.Uninterpreted_Data := Uninterpreted_Data;
  271.       Object.Pending_Call.Called_PO := Protection_Access_To_Address (Object);
  272.  
  273.       Object.Pending_Call.Called_Task := Null_Task;
  274.       Object.Pending_Call.Exception_To_Raise :=
  275.         Compiler_Exceptions.Null_Exception;
  276.  
  277.    end Protected_Entry_Call;
  278.  
  279.    --------------------------------------------
  280.    -- Vulnerable_Cancel_Protected_Entry_Call --
  281.    --------------------------------------------
  282.  
  283.    procedure Vulnerable_Cancel_Protected_Entry_Call
  284.      (Caller         : Utilities.ATCB_Ptr;
  285.       Call           : Entry_Call_Link;
  286.       PO             : Protection_Access;
  287.       Call_Cancelled : out Boolean)
  288.    is
  289.       TAS_Result : Boolean;
  290.       Ceiling_Violation : Boolean;
  291.       Old_Base_Priority : System.Priority;
  292.  
  293.    begin
  294.       Test_And_Set (Call.Call_Claimed'Address, TAS_Result);
  295.  
  296.       if TAS_Result then
  297.  
  298.          Internal_Lock (PO, Ceiling_Violation);
  299.          if Ceiling_Violation then
  300.             Write_Lock (Caller.L, Ceiling_Violation);
  301.             Old_Base_Priority := Caller.Base_Priority;
  302.             Caller.New_Base_Priority := PO.Ceiling;
  303.             Abortion.Change_Base_Priority (Caller);
  304.             Unlock (Caller.L);
  305.             Lock (PO);
  306.             PO.Old_Base_Priority := Old_Base_Priority;
  307.             PO.Pending_Action := True;
  308.          end if;
  309.  
  310.          if Onqueue (Call) then
  311.             Dequeue (PO.Entry_Queues (Protected_Entry_Index (Call.E)), Call);
  312.          end if;
  313.  
  314.       else
  315.          Write_Lock (Caller.L, Ceiling_Violation);
  316.  
  317.          while not Call.Done loop
  318.             Cond_Wait (Caller.Rend_Cond, Caller.L);
  319.          end loop;
  320.  
  321.          Unlock (Caller.L);
  322.       end if;
  323.  
  324.       Caller.ATC_Nesting_Level := Caller.ATC_Nesting_Level - 1;
  325.  
  326.       Write_Lock (Caller.L, Ceiling_Violation);
  327.  
  328.       if Caller.Pending_ATC_Level = Caller.ATC_Nesting_Level then
  329.          Caller.Pending_ATC_Level := ATC_Level_Infinity;
  330.          Caller.Aborting := False;
  331.       end if;
  332.  
  333.       Unlock (Caller.L);
  334.  
  335.       --   If we have reached the desired ATC nesting level, reset the
  336.       --   requested level to effective infinity, to allow further calls.
  337.  
  338.       Caller.Exception_To_Raise := Call.Exception_To_Raise;
  339.       Call_Cancelled := TAS_Result;
  340.  
  341.    end Vulnerable_Cancel_Protected_Entry_Call;
  342.  
  343.    -------------------------
  344.    -- Wait_For_Completion --
  345.    -------------------------
  346.  
  347.    --  Control flow procedure.
  348.    --  Abortion must be deferred before calling this procedure.
  349.  
  350.    procedure Wait_For_Completion
  351.      (Call_Cancelled : out Boolean;
  352.       Block          : in out Communication_Block)
  353.    is
  354.       Caller     : Utilities.ATCB_Ptr := ID_To_ATCB (Block.Self);
  355.       Call       : Entry_Call_Link;
  356.       PO         : Protection_Access;
  357.       Error : Boolean;
  358.  
  359.    begin
  360.  
  361.       Assert (Caller.ATC_Nesting_Level > ATC_Level_Base'First,
  362.         "Attempt to wait on a nonexistant protected entry call.");
  363.  
  364.       Call := Caller.Entry_Calls (Caller.ATC_Nesting_Level)'Access;
  365.  
  366.       Assert (Call.Mode = Simple_Call,
  367.         "Attempt to wait on a on a conditional or asynchronous call");
  368.  
  369.       PO := Address_To_Protection_Access (Call.Called_PO);
  370.  
  371.       Write_Lock (Caller.L, Error);
  372.  
  373.       if Call.Abortable then
  374.          Caller.Suspended_Abortably := True;
  375.  
  376.          while not Call.Done loop
  377.             if Caller.Pending_Action then
  378.                if Caller.Pending_Priority_Change then
  379.                   Abortion.Change_Base_Priority (Caller);
  380.                   --  requeue call at new priority
  381.                   Unlock (Caller.L);
  382.                   Lock (PO);
  383.                   if Onqueue (Call) then  --  Dequeued by proxy?
  384.                      Dequeue (PO.Entry_Queues (
  385.                        Protected_Entry_Index (Call.E)), Call);
  386.                      Enqueue (PO.Entry_Queues (
  387.                        Protected_Entry_Index (Call.E)), Call);
  388.                   end if;
  389.                   Unlock (PO);
  390.                   Write_Lock (Caller.L, Error);
  391.                end if;
  392.  
  393.                exit when
  394.                   Caller.Pending_ATC_Level < Caller.ATC_Nesting_Level;
  395.                Caller.Pending_Action := False;
  396.             end if;
  397.             Cond_Wait (Caller.Cond, Caller.L);
  398.          end loop;
  399.  
  400.          Caller.Suspended_Abortably := False;
  401.  
  402.       else
  403.          while not Call.Done loop
  404.             Cond_Wait (Caller.Cond, Caller.L);
  405.          end loop;
  406.       end if;
  407.  
  408.       Unlock (Caller.L);
  409.  
  410.       Vulnerable_Cancel_Protected_Entry_Call
  411.         (Caller, Call, PO, Call_Cancelled);
  412.  
  413.    end Wait_For_Completion;
  414.  
  415.    ---------------------------------
  416.    -- Cancel_Protected_Entry_Call --
  417.    ---------------------------------
  418.  
  419.    procedure Cancel_Protected_Entry_Call
  420.      (Call_Cancelled : out Boolean;
  421.       Block          : in out Communication_Block)
  422.    is
  423.       Caller     : Utilities.ATCB_Ptr := ID_To_ATCB (Block.Self);
  424.       Call       : Entry_Call_Link;
  425.       PO         : Protection_Access;
  426.       TAS_Result : Boolean;
  427.       Cancelled  : Boolean;
  428.  
  429.    begin
  430.       Defer_Abortion;
  431.  
  432.       Assert (Caller.ATC_Nesting_Level > ATC_Level_Base'First,
  433.         "Attempt to cancel a nonexistant task entry call.");
  434.  
  435.       Call := Caller.Entry_Calls (Caller.ATC_Nesting_Level)'Access;
  436.  
  437.       Assert (Call.Mode = Asynchronous_Call,
  438.         "Attempt to cancel a conditional or simple call");
  439.  
  440.       Assert (Call.Called_Task = Null_Task,
  441.         "Attempt to use Cancel_Protected_Entry_Call on task entry call.");
  442.  
  443.       PO := Address_To_Protection_Access (Call.Called_PO);
  444.       Vulnerable_Cancel_Protected_Entry_Call (Caller, Call, PO, Cancelled);
  445.       Undefer_Abortion;
  446.  
  447.       Call_Cancelled := Cancelled;
  448.    end Cancel_Protected_Entry_Call;
  449.  
  450.    --------------------------
  451.    -- Wait_Until_Abortable --
  452.    --------------------------
  453.  
  454.    procedure Wait_Until_Abortable (Block : in out Communication_Block) is
  455.       Caller     : Utilities.ATCB_Ptr := ID_To_ATCB (Block.Self);
  456.       Call       : Entry_Call_Link;
  457.       PO         : Protection_Access;
  458.       Error : Boolean;
  459.    begin
  460.       Assert (Caller.ATC_Nesting_Level > ATC_Level_Base'First,
  461.         "Attempt to wait for a nonexistant call to be abortable.");
  462.       Call := Caller.Entry_Calls (Caller.ATC_Nesting_Level)'Access;
  463.       Assert (Call.Mode = Asynchronous_Call,
  464.         "Attempt to wait for a non-asynchronous call to be abortable");
  465.       PO := Address_To_Protection_Access (Call.Called_PO);
  466.  
  467.       Write_Lock (Caller.L, Error);
  468.       while not Call.Abortable loop
  469.          Cond_Wait (Caller.Cond, Caller.L);
  470.       end loop;
  471.       Unlock (Caller.L);
  472.    end Wait_Until_Abortable;
  473.  
  474.    ---------------------
  475.    -- Next_Entry_Call --
  476.    ---------------------
  477.  
  478.    --   This procedure assumes that a task will have to enter the eggshell to
  479.    --   cancel a call, so there is no need to check for cancellation here.
  480.    --   This seems to obviate the need to lock the task at this point, since
  481.    --   the task will be forced to wait before doing the cancellation, meaning
  482.    --   that it will not take place.
  483.  
  484.    procedure Next_Entry_Call
  485.      (Object    : Protection_Access;
  486.       Barriers  : Barrier_Vector;
  487.       Uninterpreted_Data : out System.Address;
  488.       E         : out Protected_Entry_Index)
  489.    is
  490.       TAS_Result        : Boolean;
  491.    begin
  492.       Object.Call_In_Progress := null;
  493.       if Object.Pending_Call /= null then
  494.  
  495.          Assert (Self = Object.Pending_Call.Self,
  496.            "Pending call handled by a task that did not pend it.");
  497.  
  498.          --   Note that the main cost of the above assertion is likely
  499.          --   to be the call to Self.  If this is not optimized away,
  500.          --   nulling out Assert will not be of much value.
  501.  
  502.          if Barriers (Protected_Entry_Index (Object.Pending_Call.E)) then
  503.             Test_And_Set
  504.               (Object.Pending_Call.Call_Claimed'Address, TAS_Result);
  505.  
  506.             if TAS_Result then
  507.                Object.Call_In_Progress := Object.Pending_Call;
  508.             end if;
  509.  
  510.          else
  511.             Enqueue (
  512.               Object.Entry_Queues (
  513.               Protected_Entry_Index (Object.Pending_Call.E)),
  514.               Object.Pending_Call);
  515.             Object.Pending_Call := null;
  516.          end if;
  517.  
  518.       end if;
  519.  
  520.       if Object.Call_In_Progress = null then
  521.          Select_Protected_Entry_Call
  522.            (Object,
  523.             Barriers,
  524.             Object.Call_In_Progress);
  525.       end if;
  526.  
  527.       if Object.Call_In_Progress /= null then
  528.          E := Protected_Entry_Index (Object.Call_In_Progress.E);
  529.          Uninterpreted_Data := Object.Call_In_Progress.Uninterpreted_Data;
  530.  
  531.       else
  532.          E := Null_Protected_Entry;
  533.       end if;
  534.  
  535.    end Next_Entry_Call;
  536.  
  537.    -------------------------
  538.    -- Complete_Entry_Body --
  539.    -------------------------
  540.  
  541.    procedure Complete_Entry_Body
  542.      (Object           : Protection_Access;
  543.       Pending_Serviced : out Boolean)
  544.    is
  545.    begin
  546.       Exceptional_Complete_Entry_Body
  547.         (Object, Pending_Serviced, Compiler_Exceptions.Null_Exception);
  548.  
  549.    end Complete_Entry_Body;
  550.  
  551.    -------------------------------------
  552.    -- Exceptional_Complete_Entry_Body --
  553.    -------------------------------------
  554.  
  555.    procedure Exceptional_Complete_Entry_Body
  556.      (Object           : Protection_Access;
  557.       Pending_Serviced : out Boolean;
  558.       Ex               : Compiler_Exceptions.Exception_ID)
  559.    is
  560.       Caller : Utilities.ATCB_Ptr :=
  561.                     ID_To_ATCB (Object.Call_In_Progress.Self);
  562.       Error : Boolean;
  563.  
  564.    begin
  565.       Pending_Serviced := False;
  566.       Object.Call_In_Progress.Exception_To_Raise := Ex;
  567.  
  568.       if Object.Pending_Call /= null then
  569.          Assert (Object.Pending_Call = Object.Call_In_Progress,
  570.            "Serviced a protected entry call when another was pending");
  571.  
  572.          Pending_Serviced := True;
  573.          Caller.ATC_Nesting_Level := Caller.ATC_Nesting_Level - 1;
  574.          Object.Pending_Call := null;
  575.       end if;
  576.  
  577.       --   If we have completed a pending entry call, pop it and set the
  578.       --   Pending_Serviced flag to indicate that it is complete.
  579.  
  580.       Write_Lock (Caller.L, Error);
  581.       Object.Call_In_Progress.Done := True;
  582.       Unlock (Caller.L);
  583.  
  584.       if Object.Call_In_Progress.Mode = Asynchronous_Call then
  585.          Utilities.Abort_To_Level
  586.            (ATCB_To_ID (Caller), Object.Call_In_Progress.Level - 1);
  587.  
  588.       elsif Object.Call_In_Progress.Mode = Simple_Call then
  589.          Cond_Signal (Caller.Cond);
  590.       end if;
  591.  
  592.       Object.Pending_Call := null;
  593.  
  594.    end Exceptional_Complete_Entry_Body;
  595.  
  596.    -----------------------------
  597.    -- Requeue_Protected_Entry --
  598.    -----------------------------
  599.  
  600.    procedure Requeue_Protected_Entry
  601.      (Object     : Protection_Access;
  602.       New_Object : Protection_Access;
  603.       E          : Protected_Entry_Index;
  604.       With_Abort : Boolean)
  605.    is
  606.    begin
  607.       Object.Call_In_Progress.Abortable := With_Abort;
  608.       Object.Call_In_Progress.E := Entry_Index (E);
  609.  
  610.       if With_Abort then
  611.          Object.Call_In_Progress.Call_Claimed := False;
  612.       end if;
  613.  
  614.       if Object = New_Object then
  615.          Enqueue (New_Object.Entry_Queues (E), Object.Call_In_Progress);
  616.       else
  617.          New_Object.Pending_Call := Object.Call_In_Progress;
  618.          Object.Pending_Call := null;
  619.       end if;
  620.  
  621.    end Requeue_Protected_Entry;
  622.  
  623.    -------------------------------------
  624.    -- Requeue_Task_To_Protected_Entry --
  625.    -------------------------------------
  626.  
  627.    procedure Requeue_Task_To_Protected_Entry
  628.      (New_Object : Protection_Access;
  629.       E          : Protected_Entry_Index;
  630.       With_Abort : Boolean)
  631.    is
  632.       Old_Acceptor : Utilities.ATCB_Ptr := ID_To_ATCB (Self);
  633.       Entry_Call : Entry_Call_Link;
  634.       Error : Boolean;
  635.  
  636.    begin
  637.       Write_Lock (Old_Acceptor.L, Error);
  638.       Entry_Call := Old_Acceptor.Call;
  639.       Old_Acceptor.Call := null;
  640.       Unlock (Old_Acceptor.L);
  641.       Entry_Call.Abortable := With_Abort;
  642.       Entry_Call.E := Entry_Index (E);
  643.       Entry_Call.Called_PO := Protection_Access_To_Address (New_Object);
  644.  
  645.       if With_Abort then
  646.          Entry_Call.Call_Claimed := False;
  647.       end if;
  648.  
  649.       New_Object.Pending_Call := Entry_Call;
  650.    end Requeue_Task_To_Protected_Entry;
  651.  
  652.    ---------------------
  653.    -- Protected_Count --
  654.    ---------------------
  655.  
  656.    function Protected_Count
  657.      (Object : Protection;
  658.       E      : Protected_Entry_Index)
  659.       return   Natural
  660.    is
  661.    begin
  662.       return Count_Waiting (Object.Entry_Queues (E));
  663.    end Protected_Count;
  664.  
  665.    -----------------------------
  666.    -- Broadcast_Program_Error --
  667.    -----------------------------
  668.  
  669.    procedure Broadcast_Program_Error
  670.      (Object        : Protection_Access) is
  671.       Entry_Call    : Entry_Call_Link;
  672.       Current_Task  : Utilities.ATCB_Ptr;
  673.       Raise_In_Self : Boolean := True;
  674.       Error : Boolean;
  675.  
  676.    begin
  677.       for E in Object.Entry_Queues'Range loop
  678.          Dequeue_Head (Object.Entry_Queues (E), Entry_Call);
  679.  
  680.          while Entry_Call /= null loop
  681.             Current_Task := ID_To_ATCB (Entry_Call.Self);
  682.             Entry_Call.Exception_To_Raise :=
  683.               Compiler_Exceptions.Program_Error_ID;
  684.             Write_Lock (Current_Task.L, Error);
  685.             Entry_Call.Done := True;
  686.             Unlock (Current_Task.L);
  687.  
  688.             case Entry_Call.Mode is
  689.  
  690.                when Simple_Call =>
  691.                   Utilities.Abort_To_Level
  692.                     (ATCB_To_ID (Current_Task), Entry_Call.Level - 1);
  693.  
  694.                when Conditional_Call =>
  695.                   Assert (False, "Conditional call found on entry queue.");
  696.  
  697.                when Asynchronous_Call =>
  698.                   Utilities.Abort_To_Level
  699.                     (ATCB_To_ID (Current_Task), Entry_Call.Level - 1);
  700.  
  701.             end case;
  702.  
  703.             Dequeue_Head (Object.Entry_Queues (E), Entry_Call);
  704.          end loop;
  705.       end loop;
  706.    end Broadcast_Program_Error;
  707.  
  708. end System.Tasking.Protected_Objects;
  709.